home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _a63944ab7390cd3b751df9227d41490a < prev    next >
Encoding:
Text File  |  2002-05-30  |  2.9 KB  |  102 lines
  1. package WidgetDemo;
  2.  
  3. use 5.004;
  4. use Carp;
  5.  
  6. use vars qw($VERSION @ISA);
  7. $VERSION = '3.021'; # $Id: //depot/Tk8/demos/demos/widget_lib/WidgetDemo.pm#21 $
  8.  
  9. use Tk;
  10. use Tk::Toplevel;
  11. use strict;
  12. use base  'Tk::Toplevel';
  13. Construct Tk::Widget 'WidgetDemo';
  14.  
  15. # %WIDGDEMO is a class global that tracks all WidgetDemo composite widgets,
  16. # providing a means of destroying a previous instance of a demonstration.
  17.  
  18. my %WIDGDEMO;            # class hash of active widget demonstrations
  19.  
  20. sub Populate {
  21.     my($cw, $args) = @_;
  22.  
  23.     my (%arg_defaults) = (
  24.         -name             => 'Unknown Demo Name',
  25.     -font             => '-*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-*',
  26.     -text             => 'Unknown Demo Text',
  27.     -geometry_manager => 'pack',
  28.     );
  29.     my $name = $arg_defaults{-name};
  30.     $arg_defaults{-title} = "$name Demonstration",
  31.     $arg_defaults{-iconname} = $name;
  32.  
  33.     my(@margs, %ahsh, @args);
  34.     @margs = grep ! defined $args->{$_}, keys %arg_defaults;
  35.     %ahsh = %$args;
  36.     @ahsh{@margs} = @arg_defaults{@margs};
  37.     my($demo, $font, $text, $title, $iconname, $gm) =
  38.     @ahsh{-name, -font, -text, -title, -iconname, -geometry_manager};
  39.     delete $args->{-name};
  40.     delete $args->{-font};
  41.     delete $args->{-text};
  42.     delete $args->{-iconname};
  43.     delete $args->{-geometry_manager};
  44.  
  45.     $WIDGDEMO{$demo}->destroy if Exists($WIDGDEMO{$demo});
  46.     $WIDGDEMO{$demo} = $cw;
  47.  
  48.     $cw->SUPER::Populate($args);
  49.     $cw->iconname($iconname);
  50.  
  51.     my(@label_attributes) = ();
  52.     if (ref($text) eq 'ARRAY') {
  53.     @label_attributes = @$text[1 .. $#{$text}];
  54.     $text = $text->[0];
  55.     }
  56.     my $msg = $cw->Label(
  57.         -font       => $font,
  58.         -wraplength => '4i',
  59.         -justify    => 'left',
  60.         -text       => $text,
  61.         @label_attributes,             
  62.     );
  63.     
  64.     my $demo_frame = $cw->Frame;
  65.     $cw->Advertise('WidgetDemo' => $demo_frame); # deprecated
  66.  
  67.     my $buttons = $cw->Frame;
  68.     my $dismiss = $buttons->Button(
  69.         -text    => 'Dismiss',
  70.         -command => [$cw => 'destroy'],
  71.     );
  72.     my $see = $buttons->Button(-text => 'See Code',
  73.                    -command => [\&main::see_code, $demo]);
  74.  
  75.     if ($gm eq 'pack') {
  76.     $buttons->pack(qw/-side bottom -fill x -pady 2m/);
  77.     $dismiss->pack(qw/-side left -expand 1/);
  78.     $see->pack(qw/-side left -expand 1/);
  79.     $msg->pack;
  80.     $demo_frame->pack(qw/-fill both/);
  81.     } elsif ($gm eq 'grid') {
  82.     $msg->grid;
  83.     $demo_frame->grid;
  84.     $buttons->grid(qw/-pady 2m -sticky ew/);
  85.     $buttons->gridColumnconfigure(qw/0 -weight 1/);
  86.     $buttons->gridColumnconfigure(qw/1 -weight 1/);
  87.     $dismiss->grid(qw/-row 0 -column 0/);
  88.     $see->grid(qw/-row 0 -column 1/);
  89.     } else {
  90.     croak "Only pack or grid geometry management supported.";
  91.     }
  92.  
  93.     $cw->Delegates('Construct' => $demo_frame);
  94.     return $cw;
  95.  
  96. } # end Populate, WidgetDemo constructor
  97.  
  98. sub Top {return $_[0]->Subwidget('WidgetDemo')}    # deprecated
  99. *top = *top = \&Top;  # peacify -w
  100.  
  101. 1;
  102.